home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / scheme / pcscheme / geneva / sources.exe / SOURCES / S / HELP.S < prev    next >
Encoding:
Text File  |  1993-10-24  |  6.7 KB  |  227 lines
  1. ; HELP.S
  2. ;************************************************************************
  3. ;*                                    *
  4. ;*        PC Scheme/Geneva 4.00 Scheme code            *
  5. ;*                                    *
  6. ;* (c) 1985-1988 by Texas Instruments, Inc. See COPYRIGHT.TXT        *
  7. ;* (c) 1992 by L. Bartholdi & M. Vuilleumier, University of Geneva    *
  8. ;*                                    *
  9. ;*----------------------------------------------------------------------*
  10. ;*                                    *
  11. ;*            Help System                     *
  12. ;*                                    *
  13. ;*----------------------------------------------------------------------*
  14. ;*                                    *
  15. ;* Created by:                Date:                 *
  16. ;* Revision history:                            *
  17. ;* - 18 Jun 92:    Renaissance (Borland Compilers, ...)            *
  18. ;*                                    *
  19. ;*                    ``In nomine omnipotentii dei''    *
  20. ;************************************************************************
  21.  
  22. ;
  23. ;    A Help facility for PC Scheme
  24. ;
  25. ;    Precis of instructions:
  26. ;      1. Load this file, i.e., type (load "help.s")
  27. ;      2. To extract information on the definitions
  28. ;         in a file of Scheme source code, type
  29. ;         (extract-help "filename").
  30. ;      3. To extract the help information and
  31. ;         at the same time load the file, type
  32. ;         (load-with-help "filename").
  33. ;      4. Type (help 'ident) for information on the
  34. ;         name ident.
  35. ;      5. Type (help), without arguments, for a list
  36. ;         of all identifiers for which extended
  37. ;         help is available.
  38.  
  39. (define help
  40.   (lambda subject
  41.     (if (null? subject)
  42.         (show-help-topics)
  43.         (fetch-help (car subject)))
  44.     *the-non-printing-object*))
  45.  
  46.  
  47. (define fetch-help
  48.   (lambda (item)
  49.     (report-help item
  50.                  (get-internal-help item)
  51.                  (get-archival-help item))))
  52.  
  53. (define get-internal-help
  54.   (lambda (item)
  55.     (let ((item-class (classify item)))
  56.       (if (and (symbol? item) (bound? item))
  57.           (let* ((value       (eval item))
  58.                  (value-class (classify value)))
  59.             (list item-class value value-class))
  60.           (list item-class)))))
  61.  
  62.  
  63. (define classify
  64.   (lambda (x)
  65.     (cond ((pair?        x) 'pair)
  66.           ((procedure?   x) (cond ((closure?      x) 'procedure)
  67.                                   ((continuation? x) 'continuation)
  68.                                   (else              'engine)))
  69.           ((boolean?     x) 'boolean)
  70.           ((symbol?      x) 'symbol)
  71.           ((environment? x) 'environment)
  72.           ((stream?      x) 'stream)
  73.           ((port?        x) 'port)
  74.           ((number?      x) 'number)
  75.           ((char?        x) 'character)
  76.           ((string?      x) 'string)
  77.           ((vector?      x) 'vector)
  78.           (else             'unknown))))
  79.  
  80.  
  81. (define bound?
  82.   (lambda (ident)
  83.     (not (eval `(unbound? ,ident)))))
  84.  
  85.  
  86. (define archive
  87.   (let ((a-list '() ))
  88.     (lambda (msg . args)
  89.       (case msg
  90.         ((get)     (cadr (assq (car args) a-list)))
  91.         ((put)     (archive 'remove (car args))
  92.                    (set! a-list (cons args a-list)))
  93.         ((keys)    (map car a-list))
  94.         ((remove)  (set! a-list (delq! (assq (car args) a-list) a-list)))
  95.         (else      (error "Unrecognized message to archive:" msg))))))
  96.  
  97.  
  98. (define get-archival-help
  99.   (lambda (item)
  100.     (archive 'get item)))
  101.  
  102.  
  103. (define show-help-topics
  104.   (lambda ()
  105.     (writeln "Topics for which extended help is available:")
  106.     (for-each writeln (archive 'keys))))
  107.  
  108.  
  109. (define extract-help
  110.   (lambda (filename)
  111.     (let ((read (if (string-ci=? (cadddr (filename-split filename)) ".sw")
  112.                  read-sw read)))
  113.       (with-input-from-file filename
  114.         (lambda ()
  115.           (do ((next (read) (read)))
  116.               ((eof-object? next) 'OK)
  117.               (let ((info (parse next)))
  118.                 (when info (put-archival-help filename info)))))))))
  119.  
  120.  
  121. (define parse
  122.   (lambda (expr)
  123.     (if (and (pair? expr) (eq? (car expr) 'define))
  124.         (if (pair? (cadr expr))
  125.             (parse-mit (cadr expr))
  126.             (parse-iu (cdr expr)))
  127.         '() )))
  128.  
  129.  
  130. (define parse-mit
  131.   (lambda (expr)
  132.     (if (pair? (car expr))
  133.         (parse-mit (car expr))
  134.         (parse-params (car expr) (cdr expr)))))
  135.  
  136.  
  137. (define parse-iu
  138.   (lambda (expr)
  139.     (let ((lambda-form (get-lambda (cadr expr))))
  140.       (if lambda-form
  141.           (parse-params (car expr) (cadr lambda-form))
  142.           '() ))))
  143.  
  144.  
  145. (define get-lambda
  146.   (lambda (e)
  147.     (if (or (null? e) (atom? e))
  148.         '()
  149.         (case (car e)
  150.           ((lambda) e)
  151.           ((let let* letrec) (get-lambda (car (last-pair e))))
  152.           (else '() )))))
  153.  
  154.  
  155. (define parse-params
  156.   (lambda (name paramlist)
  157.     (let loop ((params paramlist) (count 0))
  158.       (cond ((null? params) (list name count 0 paramlist))
  159.             ((atom? params) (list name count 1 paramlist))
  160.             (else (loop (cdr params) (+ 1 count)))))))
  161.  
  162.  
  163. (define put-archival-help
  164.   (lambda (filename info)
  165.     (archive 'put (car info) (append (list filename)
  166.                                      (cdr info)))))
  167.  
  168.  
  169. (define load-with-help
  170.   (lambda (filename)
  171.     (extract-help filename)
  172.     (load filename)))
  173.  
  174.  
  175. (define report-help
  176.   (lambda (item internal-info archival-info)
  177.     (let ((item-class  (car   internal-info))
  178.           (value       (cadr  internal-info))
  179.           (value-class (caddr internal-info)))
  180.       (newline)
  181.       (cond ((not (symbol? item)) (report-literal item item-class))
  182.             ((null? value-class)  (report-unbound item))
  183.             (else                 (report-binding item value value-class)))
  184.       (when archival-info (report-archival item archival-info)))))
  185.  
  186.  
  187. (define report-literal
  188.   (lambda (item class)
  189.     (writeln item " is an object of type " class ".")
  190.     (newline)))
  191.  
  192.  
  193. (define report-unbound
  194.   (lambda (item)
  195.     (writeln "The identifier " item " is unbound.")
  196.     (newline)))
  197.  
  198.  
  199. (define report-binding
  200.   (lambda (item value class)
  201.     (writeln "The identifier " item
  202.              " is bound to an object of type " class ".")
  203.     (when (denotable? class)
  204.           (writeln "The value of " item " is " value "."))
  205.     (newline)))
  206. (define denotable?
  207.   (lambda (class)
  208.     (memq class '(boolean number character string vector pair symbol))))
  209.  
  210.  
  211. (define report-archival
  212.   (lambda (item info)
  213.     (let* ((filename (car    info))
  214.            (req-args (cadr   info))
  215.            (opt-args (caddr  info))
  216.            (params   (cadddr info))
  217.            (argstr   (if (= 1 req-args) "argument" "arguments"))
  218.            (optstr   (if (zero? opt-args) "no" "any number of")))
  219.       (writeln item " is defined in file " filename)
  220.       (writeln "as a procedure of " req-args " required " argstr)
  221.       (writeln "and " optstr " optional arguments.")
  222.       (writeln "The parameters to " item " are declared as follows:")
  223.       (writeln params)
  224.       (newline))))
  225.  
  226.  
  227.